#lang racket


(provide
 node%
 
 ; points
 point-node%
 
 ; lines
 arc-node%
 elliptical-arc-node%
 ellipse-node%
 line-node%
 nurbs-curve-node%
 spline-node%
 
 ; surfaces
 annulus-node%
 ngon-node%
 nurbs-surface-node%
 star-node%
 surface-node%
 
 ; solids
 box-node%
 cone-node%
 cone-frustum-node%
 cylinder-node%
 pyramid-node%
 sphere-node%
 
 ; generic shapes
 circle-node%
 parametric-node%
 rectangle-node%
 
 ; text
 text-node%
 
 ; transformations
 extrude-node%
 intersect-node%
 join-node%
 loft-node%
 move-node%
 offset-node%
 rotate-node%
 scale-node%
 section-node%
 slice-node%
 subtract-node%
 sweep-node%
 thicken-node%
 union-node%
 
 ; lang
 align-node%
 lift-node%
 on-node%
 sequence-node%
 
 ; cad
 layer-node%
 view-node%)


; node

(define node%
  (interface ()
    visit))

(define srcloc-node%
  (class* object% (node%)
    (super-new)
    
    (field (srcloc (list)))
    
    (define/public (visit visitor)
      (error 'visit))
    
    (define/public (add-srcloc! src)
      (set! srcloc (append srcloc (list src))))))

(define-syntax (define-node stx)
  (syntax-case stx ()
    ((ctx name (field ...) body ...)
     (let ((node-name (datum->syntax #'ctx (string->symbol (format "~A-node%" (symbol->string (syntax->datum #'name))))))
           (visit-name (datum->syntax #'ctx (string->symbol (format "visit-~A" (symbol->string (syntax->datum #'name)))))))
       #`(define #,node-name
           (class* srcloc-node% ()
             (super-new)
             
             (init-field field) ...
             
             (define/override (visit visitor)
               (send visitor #,visit-name this))
             
             body ...))))))


; points

(define-node point (c))

 
; lines

(define-node arc (angle radius))
(define-node elliptical-arc (angle x-radius y-radius))
(define-node ellipse (x-radius y-radius))
(define-node line (closed? cs))
(define-node nurbs-curve (controls knots))
(define-node spline (closed? cs type))


; surfaces

(define-node annulus (inner-radius outer-radius))
(define-node ngon (width sides))
(define-node nurbs-surface (controls u-knots v-knots))
(define-node star (width sides stride))
(define-node surface (node))


; solids

(define-node box (width length height))
(define-node cone (radius height))
(define-node cone-frustum (base-radius top-radius height))
(define-node cylinder (radius height))
(define-node pyramid (width sides height))
(define-node sphere (radius))


; generic shapes

(define-node circle (c type radius))
(define-node parametric (functional-par))
(define-node rectangle (type width length))


; text

(define-node text (t r s str))


; transformations

(define-node extrude (length dir node))
(define-node intersect (node))
(define-node join (node))
(define-node loft (loft-type loft-fit-type closed? node))
(define-node move (c node)
  (define/override (add-srcloc! src)
    (super add-srcloc! src)
    (send node add-srcloc! src)))
(define-node offset (distance node)
  (define/override (add-srcloc! src)
    (super add-srcloc! src)
    (send node add-srcloc! src)))
(define-node rotate (angle normal node)
  (define/override (add-srcloc! src)
    (super add-srcloc! src)
    (send node add-srcloc! src)))
(define-node scale (type c node)
  (define/override (add-srcloc! src)
    (super add-srcloc! src)
    (send node add-srcloc! src)))
(define-node section (type plane node))
(define-node slice (node1 node2))
(define-node subtract (node))
(define-node sweep (path node))
(define-node thicken (distance node))
(define-node union (node))


; lang

(define-node align (key-align-types key-shape shape-align-types node))
(define-node lift (proc node))
(define-node on (type node))
(define-node sequence (nodes))


; cad

(define-node layer (name node))
(define-node view (type projection-type style node))